home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / perl / os2perl / perl.c < prev    next >
C/C++ Source or Header  |  1991-06-16  |  34KB  |  1,264 lines
  1. char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.4 $$Date: 91/06/10 01:23:07 $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1991, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  * $Log:    perl.c,v $
  9.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  10.  * patch10: perl -v printed incorrect copyright notice
  11.  *
  12.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  13.  * patch4: changed old $^P to $^X
  14.  *
  15.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  16.  * patch4: new copyright notice
  17.  * patch4: added $^P variable to control calling of perldb routines
  18.  * patch4: added $^F variable to specify maximum system fd, default 2
  19.  * patch4: debugger lost track of lines in eval
  20.  *
  21.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  22.  * patch1: fixed undefined environ problem
  23.  *
  24.  * Revision 4.0  91/03/20  01:37:44  lwall
  25.  * 4.0 baseline.
  26.  *
  27.  */
  28.  
  29. #include "EXTERN.h"
  30. #include "perl.h"
  31. #include "perly.h"
  32. #include "patchlevel.h"
  33.  
  34. char *getenv();
  35.  
  36. #ifdef IAMSUID
  37. #ifndef DOSUID
  38. #define DOSUID
  39. #endif
  40. #endif
  41.  
  42. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  43. #ifdef DOSUID
  44. #undef DOSUID
  45. #endif
  46. #endif
  47.  
  48. static char* moreswitches();
  49. static char* cddir;
  50. static bool minus_c;
  51. static char patchlevel[6];
  52. static char *nrs = "\n";
  53. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  54. static int nrslen = 1;
  55.  
  56. main(argc,argv,env)
  57. register int argc;
  58. register char **argv;
  59. register char **env;
  60. {
  61.     register STR *str;
  62.     register char *s;
  63.     char *getenv();
  64.     bool dosearch = FALSE;
  65. #ifdef DOSUID
  66.     char *validarg = "";
  67. #endif
  68.  
  69. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  70. #ifdef IAMSUID
  71. #undef IAMSUID
  72.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  73. setuid perl scripts securely.\n");
  74. #endif
  75. #endif
  76.  
  77.     origargv = argv;
  78.     origargc = argc;
  79.     origenviron = environ;
  80.     uid = (int)getuid();
  81.     euid = (int)geteuid();
  82.     gid = (int)getgid();
  83.     egid = (int)getegid();
  84.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  85. #ifdef MSDOS
  86.     /*
  87.      * There is no way we can refer to them from Perl so close them to save
  88.      * space.  The other alternative would be to provide STDAUX and STDPRN
  89.      * filehandles.
  90.      */
  91.     (void)fclose(stdaux);
  92.     (void)fclose(stdprn);
  93. #endif
  94.     if (do_undump) {
  95.     origfilename = savestr(argv[0]);
  96.     do_undump = 0;
  97.     loop_ptr = -1;        /* start label stack again */
  98.     goto just_doit;
  99.     }
  100.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  101.     linestr = Str_new(65,80);
  102.     str_nset(linestr,"",0);
  103.     str = str_make("",0);        /* first used for -I flags */
  104.     curstash = defstash = hnew(0);
  105.     curstname = str_make("main",4);
  106.     stab_xhash(stabent("_main",TRUE)) = defstash;
  107.     defstash->tbl_name = "main";
  108.     incstab = hadd(aadd(stabent("INC",TRUE)));
  109.     incstab->str_pok |= SP_MULTI;
  110.     for (argc--,argv++; argc > 0; argc--,argv++) {
  111.     if (argv[0][0] != '-' || !argv[0][1])
  112.         break;
  113. #ifdef DOSUID
  114.     if (*validarg)
  115.     validarg = " PHOOEY ";
  116.     else
  117.     validarg = argv[0];
  118. #endif
  119.     s = argv[0]+1;
  120.       reswitch:
  121.     switch (*s) {
  122.     case '0':
  123.     case 'a':
  124.     case 'c':
  125.     case 'd':
  126.     case 'D':
  127.     case 'i':
  128.     case 'l':
  129.     case 'n':
  130.     case 'p':
  131.     case 'u':
  132.     case 'U':
  133.     case 'v':
  134.     case 'w':
  135.         if (s = moreswitches(s))
  136.         goto reswitch;
  137.         break;
  138.  
  139.     case 'e':
  140. #ifdef TAINT
  141.         if (euid != uid || egid != gid)
  142.         fatal("No -e allowed in setuid scripts");
  143. #endif
  144.         if (!e_fp) {
  145.             e_tmpname = savestr(TMPPATH);
  146.         (void)mktemp(e_tmpname);
  147.         e_fp = fopen(e_tmpname,"w");
  148.         if (!e_fp)
  149.             fatal("Cannot open temporary file");
  150.         }
  151.         if (argv[1]) {
  152.         fputs(argv[1],e_fp);
  153.         argc--,argv++;
  154.         }
  155.         (void)putc('\n', e_fp);
  156.         break;
  157.     case 'I':
  158. #ifdef TAINT
  159.         if (euid != uid || egid != gid)
  160.         fatal("No -I allowed in setuid scripts");
  161. #endif
  162.         str_cat(str,"-");
  163.         str_cat(str,s);
  164.         str_cat(str," ");
  165.         if (*++s) {
  166.         (void)apush(stab_array(incstab),str_make(s,0));
  167.         }
  168.         else if (argv[1]) {
  169.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  170.         str_cat(str,argv[1]);
  171.         argc--,argv++;
  172.         str_cat(str," ");
  173.         }
  174.         break;
  175.     case 'P':
  176. #ifdef TAINT
  177.         if (euid != uid || egid != gid)
  178.         fatal("No -P allowed in setuid scripts");
  179. #endif
  180.         preprocess = TRUE;
  181.         s++;
  182.         goto reswitch;
  183.     case 's':
  184. #ifdef TAINT
  185.         if (euid != uid || egid != gid)
  186.         fatal("No -s allowed in setuid scripts");
  187. #endif
  188.         doswitches = TRUE;
  189.         s++;
  190.         goto reswitch;
  191.     case 'S':
  192.         dosearch = TRUE;
  193.         s++;
  194.         goto reswitch;
  195.     case 'x':
  196.         doextract = TRUE;
  197.         s++;
  198.         if (*s)
  199.         cddir = savestr(s);
  200.         break;
  201.     case '-':
  202.         argc--,argv++;
  203.         goto switch_end;
  204.     case 0:
  205.         break;
  206.     default:
  207.         fatal("Unrecognized switch: -%s",s);
  208.     }
  209.     }
  210.   switch_end:
  211.     if (e_fp) {
  212.     (void)fclose(e_fp);
  213.     argc++,argv--;
  214.     argv[0] = e_tmpname;
  215.     }
  216.  
  217. #ifdef MSDOS
  218. #define PERLLIB_SEP ';'
  219. #else
  220. #define PERLLIB_SEP ':'
  221. #endif
  222. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  223.     {
  224.     char * s2 = getenv("PERLLIB");
  225.  
  226.     if ( s2 ) {
  227.         /* Break at all separators */
  228.         while ( *s2 ) {
  229.         /* First, skip any consecutive separators */
  230.         while ( *s2 == PERLLIB_SEP ) {
  231.             /* Uncomment the next line for PATH semantics */
  232.             /* (void)apush(stab_array(incstab),str_make(".",1)); */
  233.             s2++;
  234.         }
  235.         if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
  236.             (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
  237.             s2 = s+1;
  238.         } else {
  239.             (void)apush(stab_array(incstab),str_make(s2,0));
  240.             break;
  241.         }
  242.         }
  243.     }
  244.     }
  245. #endif /* TAINT */
  246.  
  247. #ifndef PRIVLIB
  248. #define PRIVLIB "/usr/local/lib/perl"
  249. #endif
  250.     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
  251.     (void)apush(stab_array(incstab),str_make(".",1));
  252.  
  253.     str_set(&str_no,No);
  254.     str_set(&str_yes,Yes);
  255.  
  256.     /* open script */
  257.  
  258.     if (argv[0] == Nullch)
  259. #ifdef MSDOS
  260.     {
  261.     if ( isatty(fileno(stdin)) )
  262.       moreswitches("v");
  263.     argv[0] = "-";
  264.     }
  265. #else
  266.     argv[0] = "-";
  267. #endif
  268.     if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
  269.     char *xfound = Nullch, *xfailed = Nullch;
  270.     int len;
  271.  
  272.     bufend = s + strlen(s);
  273.     while (*s) {
  274. #ifndef MSDOS
  275.         s = cpytill(tokenbuf,s,bufend,':',&len);
  276. #else
  277.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  278.         tokenbuf[len] = '\0';
  279. #endif
  280.         if (*s)
  281.         s++;
  282. #ifndef MSDOS
  283.         if (len && tokenbuf[len-1] != '/')
  284. #else
  285.         if (len && tokenbuf[len-1] != '\\')
  286. #endif
  287.         (void)strcat(tokenbuf+len,"/");
  288.         (void)strcat(tokenbuf+len,argv[0]);
  289. #ifdef DEBUGGING
  290.         if (debug & 1)
  291.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  292. #endif
  293.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  294.         continue;
  295.         if (S_ISREG(statbuf.st_mode)
  296.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  297.         xfound = tokenbuf;              /* bingo! */
  298.         break;
  299.         }
  300.         if (!xfailed)
  301.         xfailed = savestr(tokenbuf);
  302.     }
  303.     if (!xfound)
  304.         fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
  305.     if (xfailed)
  306.         Safefree(xfailed);
  307.     argv[0] = savestr(xfound);
  308.     }
  309.  
  310.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  311.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  312.  
  313.     origfilename = savestr(argv[0]);
  314.     curcmd->c_filestab = fstab(origfilename);
  315.     if (strEQ(origfilename,"-"))
  316.     argv[0] = "";
  317.     if (preprocess) {
  318.     str_cat(str,"-I");
  319.     str_cat(str,PRIVLIB);
  320. #ifdef MSDOS
  321.     (void)sprintf(buf, "\
  322. sed %s -e \"/^[^#]/b\" \
  323.  -e \"/^#[     ]*include[     ]/b\" \
  324.  -e \"/^#[     ]*define[     ]/b\" \
  325.  -e \"/^#[     ]*if[     ]/b\" \
  326.  -e \"/^#[     ]*ifdef[     ]/b\" \
  327.  -e \"/^#[     ]*ifndef[     ]/b\" \
  328.  -e \"/^#[     ]*else/b\" \
  329.  -e \"/^#[     ]*endif/b\" \
  330.  -e \"s/^#.*//\" \
  331.  %s | %s -C %s %s",
  332.       (doextract ? "-e \"1,/^#/d\n\"" : ""),
  333. #else
  334.     (void)sprintf(buf, "\
  335. /bin/sed %s -e '/^[^#]/b' \
  336.  -e '/^#[     ]*include[     ]/b' \
  337.  -e '/^#[     ]*define[     ]/b' \
  338.  -e '/^#[     ]*if[     ]/b' \
  339.  -e '/^#[     ]*ifdef[     ]/b' \
  340.  -e '/^#[     ]*ifndef[     ]/b' \
  341.  -e '/^#[     ]*else/b' \
  342.  -e '/^#[     ]*endif/b' \
  343.  -e 's/^#.*//' \
  344.  %s | %s -C %s %s",
  345.       (doextract ? "-e '1,/^#/d\n'" : ""),
  346. #endif
  347.       argv[0], CPPSTDIN, str_get(str), CPPMINUS);
  348. #ifdef DEBUGGING
  349.     if (debug & 64) {
  350.         fputs(buf,stderr);
  351.         fputs("\n",stderr);
  352.     }
  353. #endif
  354.     doextract = FALSE;
  355. #ifdef IAMSUID                /* actually, this is caught earlier */
  356.     if (euid != uid && !euid)    /* if running suidperl */
  357. #ifdef HAS_SETEUID
  358.         (void)seteuid(uid);        /* musn't stay setuid root */
  359. #else
  360. #ifdef HAS_SETREUID
  361.         (void)setreuid(-1, uid);
  362. #else
  363.         setuid(uid);
  364. #endif
  365. #endif
  366. #endif /* IAMSUID */
  367.     rsfp = mypopen(buf,"r");
  368.     }
  369.     else if (!*argv[0])
  370.     rsfp = stdin;
  371.     else
  372.     rsfp = fopen(argv[0],"r");
  373.     if (rsfp == Nullfp) {
  374. #ifdef DOSUID
  375. #ifndef IAMSUID        /* in case script is not readable before setuid */
  376.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  377.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  378.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  379.         execv(buf, origargv);    /* try again */
  380.         fatal("Can't do setuid\n");
  381.     }
  382. #endif
  383. #endif
  384.     fatal("Can't open perl script \"%s\": %s\n",
  385.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  386.     }
  387.     str_free(str);        /* free -I directories */
  388.     str = Nullstr;
  389.  
  390.     /* do we need to emulate setuid on scripts? */
  391.  
  392.     /* This code is for those BSD systems that have setuid #! scripts disabled
  393.      * in the kernel because of a security problem.  Merely defining DOSUID
  394.      * in perl will not fix that problem, but if you have disabled setuid
  395.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  396.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  397.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  398.      * discovers that it has opened a setuid script, it calls suidperl with
  399.      * the same argv that it had.  If suidperl finds that the script it has
  400.      * just opened is NOT setuid root, it sets the effective uid back to the
  401.      * uid.  We don't just make perl setuid root because that loses the
  402.      * effective uid we had before invoking perl, if it was different from the
  403.      * uid.
  404.      *
  405.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  406.      * be defined in suidperl only.  suidperl must be setuid root.  The
  407.      * Configure script will set this up for you if you want it.
  408.      *
  409.      * There is also the possibility of have a script which is running
  410.      * set-id due to a C wrapper.  We want to do the TAINT checks
  411.      * on these set-id scripts, but don't want to have the overhead of
  412.      * them in normal perl, and can't use suidperl because it will lose
  413.      * the effective uid info, so we have an additional non-setuid root
  414.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  415.      */
  416.  
  417. #ifdef DOSUID
  418.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  419.     fatal("Can't stat script \"%s\"",origfilename);
  420.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  421.     int len;
  422.  
  423. #ifdef IAMSUID
  424. #ifndef HAS_SETREUID
  425.     /* On this access check to make sure the directories are readable,
  426.      * there is actually a small window that the user could use to make
  427.      * filename point to an accessible directory.  So there is a faint
  428.      * chance that someone could execute a setuid script down in a
  429.      * non-accessible directory.  I don't know what to do about that.
  430.      * But I don't think it's too important.  The manual lies when
  431.      * it says access() is useful in setuid programs.
  432.      */
  433.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  434.         fatal("Permission denied");
  435. #else
  436.     /* If we can swap euid and uid, then we can determine access rights
  437.      * with a simple stat of the file, and then compare device and
  438.      * inode to make sure we did stat() on the same file we opened.
  439.      * Then we just have to make sure he or she can execute it.
  440.      */
  441.     {
  442.         struct stat tmpstatbuf;
  443.  
  444.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  445.         fatal("Can't swap uid and euid");    /* really paranoid */
  446.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  447.         fatal("Permission denied");    /* testing full pathname here */
  448.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  449.         tmpstatbuf.st_ino != statbuf.st_ino) {
  450.         (void)fclose(rsfp);
  451.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  452.             fprintf(rsfp,
  453. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  454. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  455.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  456.             statbuf.st_dev, statbuf.st_ino,
  457.             stab_val(curcmd->c_filestab)->str_ptr,
  458.             statbuf.st_uid, statbuf.st_gid);
  459.             (void)mypclose(rsfp);
  460.         }
  461.         fatal("Permission denied\n");
  462.         }
  463.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  464.         fatal("Can't reswap uid and euid");
  465.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  466.         fatal("Permission denied\n");
  467.     }
  468. #endif /* HAS_SETREUID */
  469. #endif /* IAMSUID */
  470.  
  471.     if (!S_ISREG(statbuf.st_mode))
  472.         fatal("Permission denied");
  473.     if (statbuf.st_mode & S_IWOTH)
  474.         fatal("Setuid/gid script is writable by world");
  475.     doswitches = FALSE;        /* -s is insecure in suid */
  476.     curcmd->c_line++;
  477.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  478.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  479.         fatal("No #! line");
  480.     s = tokenbuf+2;
  481.     if (*s == ' ') s++;
  482.     while (!isspace(*s)) s++;
  483.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  484.         fatal("Not a perl script");
  485.     while (*s == ' ' || *s == '\t') s++;
  486.     /*
  487.      * #! arg must be what we saw above.  They can invoke it by
  488.      * mentioning suidperl explicitly, but they may not add any strange
  489.      * arguments beyond what #! says if they do invoke suidperl that way.
  490.      */
  491.     len = strlen(validarg);
  492.     if (strEQ(validarg," PHOOEY ") ||
  493.         strnNE(s,validarg,len) || !isspace(s[len]))
  494.         fatal("Args must match #! line");
  495.  
  496. #ifndef IAMSUID
  497.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  498.         euid == statbuf.st_uid)
  499.         if (!do_undump)
  500.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  501. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  502. #endif /* IAMSUID */
  503.  
  504.     if (euid) {    /* oops, we're not the setuid root perl */
  505.         (void)fclose(rsfp);
  506. #ifndef IAMSUID
  507.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  508.         execv(buf, origargv);    /* try again */
  509. #endif
  510.         fatal("Can't do setuid\n");
  511.     }
  512.  
  513.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
  514. #ifdef HAS_SETEGID
  515.         (void)setegid(statbuf.st_gid);
  516. #else
  517. #ifdef HAS_SETREGID
  518.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  519. #else
  520.         setgid(statbuf.st_gid);
  521. #endif
  522. #endif
  523.     if (statbuf.st_mode & S_ISUID) {
  524.         if (statbuf.st_uid != euid)
  525. #ifdef HAS_SETEUID
  526.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  527. #else
  528. #ifdef HAS_SETREUID
  529.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  530. #else
  531.         setuid(statbuf.st_uid);
  532. #endif
  533. #endif
  534.     }
  535.     else if (uid)            /* oops, mustn't run as root */
  536. #ifdef HAS_SETEUID
  537.         (void)seteuid((UIDTYPE)uid);
  538. #else
  539. #ifdef HAS_SETREUID
  540.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  541. #else
  542.         setuid((UIDTYPE)uid);
  543. #endif
  544. #endif
  545.     uid = (int)getuid();
  546.     euid = (int)geteuid();
  547.     gid = (int)getgid();
  548.     egid = (int)getegid();
  549.     if (!cando(S_IXUSR,TRUE,&statbuf))
  550.         fatal("Permission denied\n");    /* they can't do this */
  551.     }
  552. #ifdef IAMSUID
  553.     else if (preprocess)
  554.     fatal("-P not allowed for setuid/setgid script\n");
  555.     else
  556.     fatal("Script is not setuid/setgid in suidperl\n");
  557. #else
  558. #ifndef TAINT        /* we aren't taintperl or suidperl */
  559.     /* script has a wrapper--can't run suidperl or we lose euid */
  560.     else if (euid != uid || egid != gid) {
  561.     (void)fclose(rsfp);
  562.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  563.     execv(buf, origargv);    /* try again */
  564.     fatal("Can't run setuid script with taint checks");
  565.     }
  566. #endif /* TAINT */
  567. #endif /* IAMSUID */
  568. #else /* !DOSUID */
  569. #ifndef TAINT        /* we aren't taintperl or suidperl */
  570.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  571. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  572.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  573.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  574.         ||
  575.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  576.        )
  577.         if (!do_undump)
  578.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  579. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  580. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  581.     /* not set-id, must be wrapped */
  582.     (void)fclose(rsfp);
  583.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  584.     execv(buf, origargv);    /* try again */
  585.     fatal("Can't run setuid script with taint checks");
  586.     }
  587. #endif /* TAINT */
  588. #endif /* DOSUID */
  589.  
  590. #if !defined(IAMSUID) && !defined(TAINT)
  591.  
  592.     /* skip forward in input to the real script? */
  593.  
  594.     while (doextract) {
  595.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  596.         fatal("No Perl script found in input\n");
  597.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  598.         ungetc('\n',rsfp);        /* to keep line count right */
  599.         doextract = FALSE;
  600.         if (s = instr(s,"perl -")) {
  601.         s += 6;
  602.         while (s = moreswitches(s)) ;
  603.         }
  604.         if (cddir && chdir(cddir) < 0)
  605.         fatal("Can't chdir to %s",cddir);
  606.     }
  607.     }
  608. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  609.  
  610.     defstab = stabent("_",TRUE);
  611.  
  612.     if (perldb) {
  613.     debstash = hnew(0);
  614.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  615.     curstash = debstash;
  616.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  617.     tmpstab->str_pok |= SP_MULTI;
  618.     dbargs->ary_flags = 0;
  619.     subname = str_make("main",4);
  620.     DBstab = stabent("DB",TRUE);
  621.     DBstab->str_pok |= SP_MULTI;
  622.     DBline = stabent("dbline",TRUE);
  623.     DBline->str_pok |= SP_MULTI;
  624.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  625.     tmpstab->str_pok |= SP_MULTI;
  626.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  627.     tmpstab->str_pok |= SP_MULTI;
  628.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  629.     tmpstab->str_pok |= SP_MULTI;
  630.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  631.     tmpstab->str_pok |= SP_MULTI;
  632.     curstash = defstash;
  633.     }
  634.  
  635.     /* init tokener */
  636.  
  637.     bufend = bufptr = str_get(linestr);
  638.  
  639.     savestack = anew(Nullstab);        /* for saving non-local values */
  640.     stack = anew(Nullstab);        /* for saving non-local values */
  641.     stack->ary_flags = 0;        /* not a real array */
  642.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  643.     afill(savestack,63); afill(savestack,-1);
  644.  
  645.     /* now parse the script */
  646.  
  647.     error_count = 0;
  648.     if (yyparse() || error_count) {
  649.     if (minus_c)
  650.         fatal("%s had compilation errors.\n", origfilename);
  651.     else {
  652.         fatal("Execution of %s aborted due to compilation errors.\n",
  653.         origfilename);
  654.     }
  655.     }
  656.  
  657.     New(50,loop_stack,128,struct loop);
  658. #ifdef DEBUGGING
  659.     if (debug) {
  660.     New(51,debname,128,char);
  661.     New(52,debdelim,128,char);
  662.     }
  663. #endif
  664.     curstash = defstash;
  665.  
  666.     preprocess = FALSE;
  667.     if (e_fp) {
  668.     e_fp = Nullfp;
  669.     (void)UNLINK(e_tmpname);
  670.     }
  671.  
  672.     /* initialize everything that won't change if we undump */
  673.  
  674.     if (sigstab = stabent("SIG",allstabs)) {
  675.     sigstab->str_pok |= SP_MULTI;
  676.     (void)hadd(sigstab);
  677.     }
  678.  
  679.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  680.     userinit();        /* in case linked C routines want magical variables */
  681.  
  682.     amperstab = stabent("&",allstabs);
  683.     leftstab = stabent("`",allstabs);
  684.     rightstab = stabent("'",allstabs);
  685.     sawampersand = (amperstab || leftstab || rightstab);
  686.     if (tmpstab = stabent(":",allstabs))
  687.     str_set(STAB_STR(tmpstab),chopset);
  688.     if (tmpstab = stabent("\024",allstabs))
  689.     time(&basetime);
  690.  
  691.     /* these aren't necessarily magical */
  692.     if (tmpstab = stabent(";",allstabs))
  693.     str_set(STAB_STR(tmpstab),"\034");
  694.     if (tmpstab = stabent("]",allstabs)) {
  695.     str = STAB_STR(tmpstab);
  696.     str_set(str,rcsid);
  697.     str->str_u.str_nval = atof(patchlevel);
  698.     str->str_nok = 1;
  699.     }
  700.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  701.  
  702.     stdinstab = stabent("STDIN",TRUE);
  703.     stdinstab->str_pok |= SP_MULTI;
  704.     stab_io(stdinstab) = stio_new();
  705.     stab_io(stdinstab)->ifp = stdin;
  706.     tmpstab = stabent("stdin",TRUE);
  707.     stab_io(tmpstab) = stab_io(stdinstab);
  708.     tmpstab->str_pok |= SP_MULTI;
  709.  
  710.     tmpstab = stabent("STDOUT",TRUE);
  711.     tmpstab->str_pok |= SP_MULTI;
  712.     stab_io(tmpstab) = stio_new();
  713.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  714.     defoutstab = tmpstab;
  715.     tmpstab = stabent("stdout",TRUE);
  716.     stab_io(tmpstab) = stab_io(defoutstab);
  717.     tmpstab->str_pok |= SP_MULTI;
  718.  
  719.     curoutstab = stabent("STDERR",TRUE);
  720.     curoutstab->str_pok |= SP_MULTI;
  721.     stab_io(curoutstab) = stio_new();
  722.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  723.     tmpstab = stabent("stderr",TRUE);
  724.     stab_io(tmpstab) = stab_io(curoutstab);
  725.     tmpstab->str_pok |= SP_MULTI;
  726.     curoutstab = defoutstab;        /* switch back to STDOUT */
  727.  
  728.     statname = Str_new(66,0);        /* last filename we did stat on */
  729.  
  730.     /* now that script is parsed, we can modify record separator */
  731.  
  732.     rs = nrs;
  733.     rslen = nrslen;
  734.     rschar = nrschar;
  735.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  736.  
  737.     if (do_undump)
  738.     my_unexec();
  739.  
  740.   just_doit:        /* come here if running an undumped a.out */
  741.     argc--,argv++;    /* skip name of script */
  742.     if (doswitches) {
  743.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  744.         if (argv[0][1] == '-') {
  745.         argc--,argv++;
  746.         break;
  747.         }
  748.         if (s = index(argv[0], '=')) {
  749.         *s++ = '\0';
  750.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  751.         }
  752.         else
  753.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  754.     }
  755.     }
  756. #ifdef TAINT
  757.     tainted = 1;
  758. #endif
  759.     if (tmpstab = stabent("0",allstabs)) {
  760.     str_set(stab_val(tmpstab),origfilename);
  761.     magicname("0", Nullch, 0);
  762.     }
  763.     if (tmpstab = stabent("\030",allstabs))
  764.     str_set(stab_val(tmpstab),origargv[0]);
  765.     if (argvstab = stabent("ARGV",allstabs)) {
  766.     argvstab->str_pok |= SP_MULTI;
  767.     (void)aadd(argvstab);
  768.     aclear(stab_array(argvstab));
  769.     for (; argc > 0; argc--,argv++) {
  770.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  771.     }
  772.     }
  773. #ifdef TAINT
  774.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  775. #endif
  776.     if (envstab = stabent("ENV",allstabs)) {
  777.     envstab->str_pok |= SP_MULTI;
  778.     (void)hadd(envstab);
  779.     hclear(stab_hash(envstab), FALSE);
  780.     if (env != environ)
  781.         environ[0] = Nullch;
  782.     for (; *env; env++) {
  783.         if (!(s = index(*env,'=')))
  784.         continue;
  785.         *s++ = '\0';
  786.         str = str_make(s--,0);
  787.         str_magic(str, envstab, 'E', *env, s - *env);
  788.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  789.         *s = '=';
  790.     }
  791.     }
  792. #ifdef TAINT
  793.     tainted = 0;
  794. #endif
  795.     if (tmpstab = stabent("$",allstabs))
  796.     str_numset(STAB_STR(tmpstab),(double)getpid());
  797.  
  798.     if (dowarn) {
  799.     stab_check('A','Z');
  800.     stab_check('a','z');
  801.     }
  802.  
  803.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  804.     loop_ptr = -1;        /* start label stack again */
  805.  
  806. #ifdef DEBUGGING
  807.     if (debug & 1024)
  808.     dump_all();
  809.     if (debug)
  810.     fprintf(stderr,"\nEXECUTING...\n\n");
  811. #endif
  812.  
  813.     if (minus_c) {
  814.     fprintf(stderr,"%s syntax OK\n", origfilename);
  815.     exit(0);
  816.     }
  817.  
  818.     /* do it */
  819.  
  820.     (void) cmd_exec(main_root,G_SCALAR,-1);
  821.  
  822.     if (goto_targ)
  823.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  824.     exit(0);
  825.     /* NOTREACHED */
  826. }
  827.  
  828. void
  829. magicalize(list)
  830. register char *list;
  831. {
  832.     char sym[2];
  833.  
  834.     sym[1] = '\0';
  835.     while (*sym = *list++)
  836.     magicname(sym, Nullch, 0);
  837. }
  838.  
  839. void
  840. magicname(sym,name,namlen)
  841. char *sym;
  842. char *name;
  843. int namlen;
  844. {
  845.     register STAB *stab;
  846.  
  847.     if (stab = stabent(sym,allstabs)) {
  848.     stab_flags(stab) = SF_VMAGIC;
  849.     str_magic(stab_val(stab), stab, 0, name, namlen);
  850.     }
  851. }
  852.  
  853. void
  854. savelines(array, str)
  855. ARRAY *array;
  856. STR *str;
  857. {
  858.     register char *s = str->str_ptr;
  859.     register char *send = str->str_ptr + str->str_cur;
  860.     register char *t;
  861.     register int line = 1;
  862.  
  863.     while (s && s < send) {
  864.     STR *tmpstr = Str_new(85,0);
  865.  
  866.     t = index(s, '\n');
  867.     if (t)
  868.         t++;
  869.     else
  870.         t = send;
  871.  
  872.     str_nset(tmpstr, s, t - s);
  873.     astore(array, line++, tmpstr);
  874.     s = t;
  875.     }
  876. }
  877.  
  878. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  879.  
  880. int
  881. do_eval(str,optype,stash,gimme,arglast)
  882. STR *str;
  883. int optype;
  884. HASH *stash;
  885. int gimme;
  886. int *arglast;
  887. {
  888.     STR **st = stack->ary_array;
  889.     int retval;
  890.     CMD *myroot = Nullcmd;
  891.     ARRAY *ar;
  892.     int i;
  893.     CMD * VOLATILE oldcurcmd = curcmd;
  894.     VOLATILE int oldtmps_base = tmps_base;
  895.     VOLATILE int oldsave = savestack->ary_fill;
  896.     VOLATILE int oldperldb = perldb;
  897.     SPAT * VOLATILE oldspat = curspat;
  898.     SPAT * VOLATILE oldlspat = lastspat;
  899.     static char *last_eval = Nullch;
  900.     static CMD *last_root = Nullcmd;
  901.     VOLATILE int sp = arglast[0];
  902.     char *specfilename;
  903.     char *tmpfilename;
  904.     int parsing = 1;
  905.  
  906.     tmps_base = tmps_max;
  907.     if (curstash != stash) {
  908.     (void)savehptr(&curstash);
  909.     curstash = stash;
  910.     }
  911.     str_set(stab_val(stabent("@",TRUE)),"");
  912.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  913.     perldb = FALSE;
  914.     curcmd = &compiling;
  915.     if (optype == O_EVAL) {        /* normal eval */
  916.     curcmd->c_filestab = fstab("(eval)");
  917.     curcmd->c_line = 1;
  918.     str_sset(linestr,str);
  919.     str_cat(linestr,";\n");        /* be kind to them */
  920.     if (perldb)
  921.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  922.     }
  923.     else {
  924.     if (last_root && !in_eval) {
  925.         Safefree(last_eval);
  926.         last_eval = Nullch;
  927.         cmd_free(last_root);
  928.         last_root = Nullcmd;
  929.     }
  930.     specfilename = str_get(str);
  931.     str_set(linestr,"");
  932.     if (optype == O_REQUIRE && &str_undef !=
  933.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  934.         curcmd = oldcurcmd;
  935.         tmps_base = oldtmps_base;
  936.         st[++sp] = &str_yes;
  937.         perldb = oldperldb;
  938.         return sp;
  939.     }
  940.     tmpfilename = savestr(specfilename);
  941.     if (index("/.", *tmpfilename))
  942.         rsfp = fopen(tmpfilename,"r");
  943.     else {
  944.         ar = stab_array(incstab);
  945.         for (i = 0; i <= ar->ary_fill; i++) {
  946.         (void)sprintf(buf, "%s/%s",
  947.           str_get(afetch(ar,i,TRUE)), specfilename);
  948.         rsfp = fopen(buf,"r");
  949.         if (rsfp) {
  950.             char *s = buf;
  951.  
  952.             if (*s == '.' && s[1] == '/')
  953.             s += 2;
  954.             Safefree(tmpfilename);
  955.             tmpfilename = savestr(s);
  956.             break;
  957.         }
  958.         }
  959.     }
  960.     curcmd->c_filestab = fstab(tmpfilename);
  961.     Safefree(tmpfilename);
  962.     tmpfilename = Nullch;
  963.     if (!rsfp) {
  964.         curcmd = oldcurcmd;
  965.         tmps_base = oldtmps_base;
  966.         if (optype == O_REQUIRE) {
  967.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  968.         if (instr(tokenbuf,".h "))
  969.             strcat(tokenbuf," (change .h to .ph maybe?)");
  970.         if (instr(tokenbuf,".ph "))
  971.             strcat(tokenbuf," (did you run h2ph?)");
  972.         fatal("%s",tokenbuf);
  973.         }
  974.         if (gimme != G_ARRAY)
  975.         st[++sp] = &str_undef;
  976.         perldb = oldperldb;
  977.         return sp;
  978.     }
  979.     curcmd->c_line = 0;
  980.     }
  981.     in_eval++;
  982.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  983.     bufend = bufptr + linestr->str_cur;
  984.     if (++loop_ptr >= loop_max) {
  985.     loop_max += 128;
  986.     Renew(loop_stack, loop_max, struct loop);
  987.     }
  988.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  989.     loop_stack[loop_ptr].loop_sp = sp;
  990. #ifdef DEBUGGING
  991.     if (debug & 4) {
  992.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  993.     }
  994. #endif
  995.     eval_root = Nullcmd;
  996.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  997.     retval = 1;
  998.     }
  999.     else {
  1000.     error_count = 0;
  1001.     if (rsfp) {
  1002.         retval = yyparse();
  1003.         retval |= error_count;
  1004.     }
  1005.     else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
  1006.         retval = 0;
  1007.         eval_root = last_root;    /* no point in reparsing */
  1008.     }
  1009.     else if (in_eval == 1) {
  1010.         if (last_root) {
  1011.         Safefree(last_eval);
  1012.         last_eval = Nullch;
  1013.         cmd_free(last_root);
  1014.         }
  1015.         last_root = Nullcmd;
  1016.         last_eval = savestr(bufptr);
  1017.         retval = yyparse();
  1018.         retval |= error_count;
  1019.         if (!retval)
  1020.         last_root = eval_root;
  1021.         if (!last_root) {
  1022.         Safefree(last_eval);
  1023.         last_eval = Nullch;
  1024.         }
  1025.     }
  1026.     else
  1027.         retval = yyparse();
  1028.     }
  1029.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1030.  
  1031.     if (retval) {
  1032.     st = stack->ary_array;
  1033.     sp = arglast[0];
  1034.     if (gimme != G_ARRAY)
  1035.         st[++sp] = &str_undef;
  1036.     if (parsing) {
  1037. #ifndef MANGLEDPARSE
  1038. #ifdef DEBUGGING
  1039.         if (debug & 128)
  1040.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1041. #endif
  1042.         cmd_free(eval_root);
  1043. #endif
  1044.         if (eval_root == last_root)
  1045.         last_root = Nullcmd;
  1046.         eval_root = myroot = Nullcmd;
  1047.     }
  1048.     if (rsfp) {
  1049.         fclose(rsfp);
  1050.         rsfp = 0;
  1051.     }
  1052.     }
  1053.     else {
  1054.     parsing = 0;
  1055.     sp = cmd_exec(eval_root,gimme,sp);
  1056.     st = stack->ary_array;
  1057.     for (i = arglast[0] + 1; i <= sp; i++)
  1058.         st[i] = str_mortal(st[i]);
  1059.                 /* if we don't save result, free zaps it */
  1060.     if (in_eval != 1 && myroot != last_root)
  1061.         cmd_free(myroot);
  1062.     }
  1063.  
  1064.     perldb = oldperldb;
  1065.     in_eval--;
  1066. #ifdef DEBUGGING
  1067.     if (debug & 4) {
  1068.     char *tmps = loop_stack[loop_ptr].loop_label;
  1069.     deb("(Popping label #%d %s)\n",loop_ptr,
  1070.         tmps ? tmps : "" );
  1071.     }
  1072. #endif
  1073.     loop_ptr--;
  1074.     tmps_base = oldtmps_base;
  1075.     curspat = oldspat;
  1076.     lastspat = oldlspat;
  1077.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1078.     restorelist(oldsave);
  1079.  
  1080.     if (optype != O_EVAL) {
  1081.     if (retval) {
  1082.         if (optype == O_REQUIRE)
  1083.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1084.     }
  1085.     else {
  1086.         curcmd = oldcurcmd;
  1087.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1088.         (void)hstore(stab_hash(incstab), specfilename,
  1089.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1090.               0 );
  1091.         }
  1092.         else if (optype == O_REQUIRE)
  1093.         fatal("%s did not return a true value", specfilename);
  1094.     }
  1095.     }
  1096.     curcmd = oldcurcmd;
  1097.     return sp;
  1098. }
  1099.  
  1100. /* This routine handles any switches that can be given during run */
  1101.  
  1102. static char *
  1103. moreswitches(s)
  1104. char *s;
  1105. {
  1106.     int numlen;
  1107.  
  1108.   reswitch:
  1109.     switch (*s) {
  1110.     case '0':
  1111.     nrschar = scanoct(s, 4, &numlen);
  1112.     nrs = nsavestr("\n",1);
  1113.     *nrs = nrschar;
  1114.     if (nrschar > 0377) {
  1115.         nrslen = 0;
  1116.         nrs = "";
  1117.     }
  1118.     else if (!nrschar && numlen >= 2) {
  1119.         nrslen = 2;
  1120.         nrs = "\n\n";
  1121.         nrschar = '\n';
  1122.     }
  1123.     return s + numlen;
  1124.     case 'a':
  1125.     minus_a = TRUE;
  1126.     s++;
  1127.     return s;
  1128.     case 'c':
  1129.     minus_c = TRUE;
  1130.     s++;
  1131.     return s;
  1132.     case 'd':
  1133. #ifdef TAINT
  1134.     if (euid != uid || egid != gid)
  1135.         fatal("No -d allowed in setuid scripts");
  1136. #endif
  1137.     perldb = TRUE;
  1138.     s++;
  1139.     return s;
  1140.     case 'D':
  1141. #ifdef DEBUGGING
  1142. #ifdef TAINT
  1143.     if (euid != uid || egid != gid)
  1144.         fatal("No -D allowed in setuid scripts");
  1145. #endif
  1146.     debug = atoi(s+1) | 32768;
  1147. #else
  1148.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1149. #endif
  1150.     for (s++; isdigit(*s); s++) ;
  1151.     return s;
  1152.     case 'i':
  1153.     inplace = savestr(s+1);
  1154.     for (s = inplace; *s && !isspace(*s); s++) ;
  1155.     *s = '\0';
  1156.     break;
  1157.     case 'I':
  1158. #ifdef TAINT
  1159.     if (euid != uid || egid != gid)
  1160.         fatal("No -I allowed in setuid scripts");
  1161. #endif
  1162.     if (*++s) {
  1163.         (void)apush(stab_array(incstab),str_make(s,0));
  1164.     }
  1165.     else
  1166.         fatal("No space allowed after -I");
  1167.     break;
  1168.     case 'l':
  1169.     minus_l = TRUE;
  1170.     s++;
  1171.     if (isdigit(*s)) {
  1172.         ors = savestr("\n");
  1173.         orslen = 1;
  1174.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1175.         s += numlen;
  1176.     }
  1177.     else {
  1178.         ors = nsavestr(nrs,nrslen);
  1179.         orslen = nrslen;
  1180.     }
  1181.     return s;
  1182.     case 'n':
  1183.     minus_n = TRUE;
  1184.     s++;
  1185.     return s;
  1186.     case 'p':
  1187.     minus_p = TRUE;
  1188.     s++;
  1189.     return s;
  1190.     case 'u':
  1191.     do_undump = TRUE;
  1192.     s++;
  1193.     return s;
  1194.     case 'U':
  1195.     unsafe = TRUE;
  1196.     s++;
  1197.     return s;
  1198.     case 'v':
  1199.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1200.     fputs(rcsid,stdout);
  1201.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1202. #ifdef MSDOS
  1203.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1204.     stdout);
  1205. #ifdef OS2
  1206.         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
  1207.         stdout);
  1208. #endif
  1209. #endif
  1210.     fputs("\n\
  1211. Perl may be copied only under the terms of either the Artistic License or the\n\
  1212. GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
  1213. #ifdef MSDOS
  1214.         usage(origargv[0]);
  1215. #endif
  1216.     exit(0);
  1217.     case 'w':
  1218.     dowarn = TRUE;
  1219.     s++;
  1220.     return s;
  1221.     case ' ':
  1222.     case '\n':
  1223.     case '\t':
  1224.     break;
  1225.     default:
  1226.     fatal("Switch meaningless after -x: -%s",s);
  1227.     }
  1228.     return Nullch;
  1229. }
  1230.  
  1231. /* compliments of Tom Christiansen */
  1232.  
  1233. /* unexec() can be found in the Gnu emacs distribution */
  1234.  
  1235. my_unexec()
  1236. {
  1237. #ifdef UNEXEC
  1238.     int    status;
  1239.     extern int etext;
  1240.     static char dumpname[BUFSIZ];
  1241.     static char perlpath[256];
  1242.  
  1243.     sprintf (dumpname, "%s.perldump", origfilename);
  1244.     sprintf (perlpath, "%s/perl", BIN);
  1245.  
  1246.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1247.     if (status)
  1248.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1249.     exit(status);
  1250. #else
  1251. #ifdef MSDOS
  1252.     abort();    /* nothing else to do */
  1253. #else /* ! MSDOS */
  1254. #   ifndef SIGABRT
  1255. #    define SIGABRT SIGILL
  1256. #   endif
  1257. #   ifndef SIGILL
  1258. #    define SIGILL 6        /* blech */
  1259. #   endif
  1260.     kill(getpid(),SIGABRT);    /* for use with undump */
  1261. #endif /* ! MSDOS */
  1262. #endif
  1263. }
  1264.